home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / setup < prev    next >
Text File  |  1998-07-03  |  26KB  |  1,053 lines
  1. (*
  2. This is the first file compiled in the PPC Mops image.  CROSS (in cg6)
  3. switches 68k Mops to generating PPC code.
  4.  
  5. At the beginning of the code area, there's an info block with certain
  6. quantities we need to set everything up.  Here's the format - note that
  7. this MUST AGREE with what we have in cg4/zPEF!
  8.  
  9. ent pt offset      length        what it is
  10.  
  11.     0            4 bytes        initial branch
  12.     4            4 bytes        code size
  13.     8            4 bytes        data size
  14.     12            4 bytes        displacement from code_start to nuc_code_start
  15.                                 (i.e. code generator code size)
  16.     16            4 bytes        displacement from data_start to nuc_data_start
  17.                                 (i.e. code generator data size)
  18.     20            32 bytes    initial CONTEXT
  19.     52             4 bytes    flags
  20.     56             4 bytes    #bytes chopped from bottom of seg 8
  21.     60             4 bytes    #bytes chopped from bottom of seg 9
  22.                 10 bytes    spare
  23.  
  24.         total: 80 bytes.
  25.  
  26. *)
  27.  
  28. cross
  29.  
  30. marker m__setup        ¥ also marks the start of the PPC dic
  31.  
  32. : NULL  ;
  33.  
  34. ¥    ================== REGISTER DEFINITIONS  ===================
  35.  
  36. ¥ r0 is scratch
  37.  
  38. 0    constant    false
  39. -1    constant    true
  40.  
  41. 1    constant    sys_SP_reg
  42. 2    constant    RTOC_reg
  43. 10    constant    rZ_reg
  44. 11    constant    rX_reg
  45. 12    constant    rY_reg
  46. 13    constant    mainCode_reg
  47. 14    constant    mainData_reg
  48. 15    constant    modCode_reg
  49. 16    constant    modData_reg
  50. 17    constant    RP_reg
  51. 18    constant    SP_reg
  52. 19    constant    FSP_reg
  53. 20    constant    obj_base_reg
  54. 21    constant    I_reg            ¥ can be used for a local if no DO...LOOP
  55.                                 ¥  or FOR...NEXT
  56. 22    constant    do_limit_reg    ¥ can be used for a local if no DO..LOOP
  57.  
  58. 21    constant    1st_gpr_local
  59. 14    constant    1st_fpr_local
  60.  
  61.  
  62. ¥ Now we define some constants, values etc. which we need at setup time.
  63. ¥ Most of the others are defined near the start of pnuc1.
  64.  
  65. 800  cells    constant    RSTACK_SIZE
  66. 1000 cells    constant    STACK_SIZE
  67. 200 3 <<    constant    FSTACK_SIZE
  68. $ 100000    constant    EXTRA_CODE        ¥ extra code space in dic.  Change
  69.                                         ¥  to anything you like before saving
  70.                                         ¥  an image.
  71. $ 10000        constant    EXTRA_DATA        ¥ extra data space in dic.
  72. 4            constant    1CELL
  73. $ 7FFFFFFF    constant    BIG#
  74. 65520        constant    DISPL_RANGE        ¥ what we can fit in a signed 16-bits
  75.                                         ¥  displacement, rounded down to
  76.                                         ¥  8-byte alignment
  77. 32760        constant    HALF_DISPL_RANGE
  78.  
  79. $ FFA00103    constant    nilP
  80. $ FFA00101    constant    nilH
  81.  
  82. $ 7FF01000    constant    quietNAN    ¥ NAN(128) (quiet)
  83.  
  84. 204            constant    FCBlen
  85. 30            constant    HOLDlen
  86. 200            constant    PADlen
  87. 400            constant    TIBlen
  88. 512            constant    ErrDumpLen
  89.  
  90. true        constant    PPC?        ¥ ALWAYS true from CROSS onwards, by definition!
  91.  
  92.  
  93. ErrDumpLen  8 / 5 -
  94.             constant    maxDump
  95.  
  96. FCBlen HOLDlen + PADlen + TIBlen + ErrDumpLen + 8 +
  97.             constant    FBlkLen        ¥ the extra 8 is for the object header
  98.  
  99.  
  100. entry_point_toc_offset
  101.             constant    entry_point_TOC_offset
  102.  
  103.  
  104. $ 33333333    value        dd        ¥ testing - start of data area,
  105.                                 ¥  straight after TOC
  106.  
  107. ' null        vect        OBJINIT
  108.  
  109. 0            value        CDP
  110. 0            value        DP
  111. 0            value        mod_seg#        ¥ code seg# of currently running module, or 0
  112. 0            value        comp_seg#        ¥ code seg# of module being compiled, or 0
  113. 0            value        last_RP_seg#    ¥ seg# of last reloc pointer processed by @abs
  114.  
  115. 0            value        prev_CDP        ¥ used in finding range for fix_caches
  116.  
  117. 0            value        PAD
  118. 0            value        TIB
  119. 0            value        ^errDump
  120. 0            value        theRgn
  121. 0            value        SP0
  122. 0            value        RP0
  123. 0            value        FSP0
  124. 0            value        CONTEXT
  125.  
  126. false        value        instld?
  127. true        value        fWind?
  128. false        value        EMIT?
  129.  
  130. 0            value        code_start
  131. 0            value        nuc_code_start
  132. 0            value        code_limit
  133.  
  134. 0            value        data_start
  135. 0            value        nuc_data_start
  136. 0            value        data_limit
  137.  
  138. false        value        bugtest?
  139.  
  140.             variable    ftemp    4 reserve        ¥ temp area for FP stuff
  141.  
  142. -1            value        modcode_comp_start
  143. -1            value        moddata_comp_start
  144.  
  145. 0            value        compmod        ¥ addr of module object during compilation
  146.                                     ¥  of that module, otherwise zero
  147.  
  148. 64            constant    max_segs    ¥ allows us 31 modules, since each
  149.                                     ¥ has a code and data segment.
  150.                                     ¥ Change if necessary.
  151.  
  152.             variable    segTable    max_segs 3 <<  reserve
  153.  
  154.  
  155. forward    DIE            ¥ ( err# -- )  our normal Mops error handling word
  156. forward RUN            ¥ ( -- )  starts running after we set everything up
  157. forward ENTERMOD    ¥ ( xt -- )  in zModules.  Calls a word in a module.
  158. forward .S
  159. forward FIX_CACHES
  160. forward fmrk
  161.  
  162.  
  163. ¥ : HERE        inline{ DP}  ;
  164.  
  165.  
  166. (*        ====================== Objects, etc. ============================
  167.  
  168.     These are the ones we need for the very early stuff, before our full object
  169.     handling is loaded.  We therefore need to wind them by hand, and in some
  170.     cases patch them later.
  171.  
  172. *)
  173.  
  174.             create        FFCB   8 allot        ¥ will be an object pointer
  175.  
  176.  
  177.             (createObj) fWind
  178.                 $ 9C    allot
  179.                 8        allot
  180.                 $ 2E    allot
  181.                 
  182.  
  183.             (createObj) fpRect
  184.                 8        allot
  185.             
  186.             (createObj) fEvent
  187.                 18        allot            ¥ ivars space
  188.                 4  ,                    ¥ indexed elt width - &&&& changed from 2 to 4 bytes
  189.                 23 ,                    ¥ #elts - 1
  190.                 24 4*    allot            ¥ allocate space for them
  191.                 
  192.                         ¥ ## note we set the offset to the indexed area in file Event
  193.                         ¥  when we set the class pointer, since that's what we do on
  194.                         ¥  the 68k and also it's easier to make changes.
  195.  
  196.  
  197. 0            value        InterfaceLib_connID
  198. 0            value        MathLib_connID
  199.  
  200.             variable    vConnID
  201.             variable    mainAddr
  202.             variable    symAddr
  203.             variable    symClass
  204.  
  205. $ 1234 ,
  206.             create        qd        512 allot
  207. $ 4567 ,
  208.                         ¥ size of QD globals - 206 plus a generous safety
  209.                         ¥  margin which we seem to need for some unknown
  210.                         ¥  reason
  211.  
  212.             create        errName        ¥ can use same space as the following:
  213.  
  214.             create        BUF255        256 allot        ¥ buffer for string operations
  215.  
  216.  
  217. ¥ we need these very early:
  218.  
  219. ¥ $ BD3E 0  special_op        >R
  220. ¥ $ BD3F 0  special_op        R>
  221.  
  222. ¥ R@ is defined in cg5 since it's just a base-displ fetch
  223.  
  224.  
  225. ¥ Currently I'm using locked handles for things like the dictionary
  226. ¥  area - I could use pointers but using handles allows the possibility
  227. ¥  of a dynamic size change if we ever want it.
  228.  
  229. : lockedHndl { siz ¥ hndl addr -- addr }
  230.     siz %_NewHandleClear  -> hndl
  231.     hndl %_MoveHHi
  232.     hndl %_HLock
  233.     hndl @  -> addr
  234.     addr
  235. ;
  236.  
  237. ¥ inline calls are a bit long-winded, so here we factor out a couple that
  238. ¥  we need several times:
  239.  
  240. : BYE    %_ExitToShell  ;
  241.  
  242. : call_BlockMove        ¥ ( src dst len -- )  Just to save some space, since
  243.                         ¥  inline calls are a bit long-winded.  We use BlockMove
  244.                         ¥  at this stage rather than BlockMoveData, since we 
  245.                         ¥  might be moving code.
  246.     %_BlockMove  ;
  247.  
  248.  
  249. : BEEP
  250.     %_SysBeep  ;
  251.  
  252.  
  253. : ?startUpError    ¥ ( err# -- )
  254.     dup
  255.     IF  3 beep
  256.         bye
  257.     ELSE
  258.         drop
  259.     THEN  ;
  260.  
  261. : ?symbolError    ¥ ( err# -- )
  262.     dup
  263.     IF  213 die
  264.     ELSE
  265.         drop
  266.     THEN  ;
  267.  
  268.  
  269. : SWITCH_ME  { entPt addr -- }
  270.     lr>treg                    ¥ gets the return addr to treg
  271.     treg entPt -            ¥ offset of RA in code block
  272.     addr +                    ¥ equivalent RA in new code block
  273.     -> treg  treg>lr
  274. ;
  275.  
  276.  
  277. ¥ @ABS and EXECUTE have to come here, since they're invoked by executing
  278. ¥  a vector, which we need in SETUP.
  279.  
  280.  
  281. : (@ABS)  { addr ¥ relocAddr seg# baseAddr displ ^ST -- absAddr | -- 0 }
  282.     addr @  -> relocAddr
  283.     relocAddr  $ ffffff and  -> displ
  284.     relocAddr  24 >>  dup -> seg#  
  285.     dup 1 and NIF -> last_RP_seg# ELSE drop THEN
  286.  
  287.     seg# 8 <  seg#  max_segs 8 + >=  or
  288.     IF    0  EXIT  THEN
  289.     
  290.     seg# 8 -  8 *  segTable +  -> ^ST
  291.                                 ¥ get addr of the seg table entry we want
  292.  
  293. ¥ OK so far - now we check if the displ is within the segment
  294. ¥  this check will also trap an unallocated segment which will
  295. ¥  have zero length.
  296.  
  297.     displ  ^ST @ $ 00ffffff and  u>=  IF  0 EXIT  THEN
  298.                                             ¥ err if displ out of bounds
  299.     ^ST 4+ @ -> baseAddr
  300.     baseAddr nilP = IF  206 die  THEN        ¥ internal error if seg absent
  301.     baseAddr displ +
  302. ;
  303.  
  304. : @ABS  ( ^relocAddr -- absAddr )
  305.     (@abs)  dup ?EXIT
  306.     drop  70 die        ¥ "not a reloc addr"
  307. ;
  308.  
  309.  
  310. (*    For EXECUTE, we have to resort to assembly since we have to get the right
  311.     number of stack cells into regs as required by the defn we're calling, and
  312.     ditto for the returned results.
  313.     
  314.     On entry, r4 (TOS) = cfa of defn.  This is the addr of the flag bytes.
  315.     The actual code starts 2 bytes later.
  316.     
  317.     Note all assemby defns are assumed to have r4 = TOS and r3 = second,
  318.     on both entry and exit.  We override this in EXECUTE - see the comment there.
  319. *)
  320.  
  321. forward execErr
  322.  
  323.  
  324. :ppc_code PUSHES
  325.     r10        -32    rSP        stw,
  326.     r9        -28 rSP        stw,
  327.     r8        -24 rSP        stw,
  328.     r7        -20 rSP        stw,
  329.     r6        -16 rSP        stw,
  330.     r5        -12 rSP        stw,
  331.     r4        -8    rSP        stw,
  332.     r3        -4    rSP        stw,
  333.                     blr,
  334. ;ppc_code
  335.  
  336.  
  337. :ppc_code PULLS
  338.     r10        4    rSP        lwzu,
  339.     r9        4    rSP        lwzu,
  340.     r8        4    rSP        lwzu,
  341.     r7        4    rSP        lwzu,
  342.     r6        4    rSP        lwzu,
  343.     r5        4    rSP        lwzu,
  344.     r4        4    rSP        lwzu,
  345.     r3        4    rSP        lwzu,
  346.                         blr,
  347. ;ppc_code
  348.  
  349.  
  350. :ppc_code FPUSHES
  351.     fr8        -64    rFSP    stfd,
  352.     fr7        -56 rFSP    stfd,
  353.     fr6        -48 rFSP    stfd,
  354.     fr5        -40 rFSP    stfd,
  355.     fr4        -32 rFSP    stfd,
  356.     fr3        -24 rFSP    stfd,
  357.     fr2        -16    rFSP    stfd,
  358.     fr1        -8    rFSP    stfd,
  359.                         blr,
  360. ;ppc_code
  361.  
  362.  
  363. :ppc_code FPULLS
  364.     fr10    8    rFSP    lfdu,
  365.     fr9        8    rFSP    lfdu,
  366.     fr8        8    rFSP    lfdu,
  367.     fr7        8    rFSP    lfdu,
  368.     fr6        8    rFSP    lfdu,
  369.     fr5        8    rFSP    lfdu,
  370.     fr4        8    rFSP    lfdu,
  371.     fr3        8    rFSP    lfdu,
  372.     fr2        8    rFSP    lfdu,
  373.     fr1        8    rFSP    lfdu,
  374.                         blr,
  375. ;ppc_code
  376.  
  377.  
  378. :ppc_code PULLPARMS
  379.     r24        4    rSP        lwzu,
  380.     r25        4    rSP        lwzu,
  381.     r26        4    rSP        lwzu,
  382.     r27        4    rSP        lwzu,
  383.     r28        4    rSP        lwzu,
  384.     r29        4    rSP        lwzu,
  385.     r30        4    rSP        lwzu,
  386.     r31        4    rSP        lwzu,
  387.                         blr,
  388. ;ppc_code
  389.  
  390.  
  391. :ppc_code FPULLPARMS
  392.     fr24    8    rFSP    lfdu,
  393.     fr25    8    rFSP    lfdu,
  394.     fr26    8    rFSP    lfdu,
  395.     fr27    8    rFSP    lfdu,
  396.     fr28    8    rFSP    lfdu,
  397.     fr29    8    rFSP    lfdu,
  398.     fr30    8    rFSP    lfdu,
  399.     fr31    8    rFSP    lfdu,
  400.                         blr,
  401. ;ppc_code
  402.  
  403.  
  404. :ppc_code SAVES
  405.     r21        -44    rRP        stw,
  406.     r22        -40    rRP        stw,
  407.     r23        -36    rRP        stw,
  408.     r24        -32    rRP        stw,
  409.     r25        -28    rRP        stw,
  410.     r26        -24    rRP        stw,
  411.     r27        -20    rRP        stw,
  412.     r28        -16    rRP        stw,
  413.     r29        -12    rRP        stw,
  414.     r30        -8    rRP        stw,
  415.     r31        -4    rRP        stw,
  416.                         blr,
  417. ;ppc_code
  418.  
  419.  
  420. :ppc_code RESTORES
  421.     r21        -44    rRP        lwz,
  422.     r22        -40    rRP        lwz,
  423.     r23        -36    rRP        lwz,
  424.     r24        -32    rRP        lwz,
  425.     r25        -28    rRP        lwz,
  426.     r26        -24    rRP        lwz,
  427.     r27        -20    rRP        lwz,
  428.     r28        -16    rRP        lwz,
  429.     r29        -12    rRP        lwz,
  430.     r30        -8    rRP        lwz,
  431.     r31        -4    rRP        lwz,
  432.                         blr,
  433. ;ppc_code
  434.  
  435.  
  436. :ppc_code FSAVES
  437.     fr21    -88    rRP        stfd,
  438.     fr22    -80    rRP        stfd,
  439.     fr23    -72    rRP        stfd,
  440.     fr24    -64    rRP        stfd,
  441.     fr25    -56 rRP        stfd,
  442.     fr26    -48 rRP        stfd,
  443.     fr27    -40 rRP        stfd,
  444.     fr28    -32 rRP        stfd,
  445.     fr29    -24 rRP        stfd,
  446.     fr30    -16    rRP        stfd,
  447.     fr31    -8    rRP        stfd,
  448.                         blr,
  449. ;ppc_code
  450.  
  451.  
  452. :ppc_code FRESTORES
  453.     fr21    -88    rRP        lfd,
  454.     fr22    -80    rRP        lfd,
  455.     fr23    -72    rRP        lfd,
  456.     fr24    -64    rRP        lfd,
  457.     fr25    -56 rRP        lfd,
  458.     fr26    -48 rRP        lfd,
  459.     fr27    -40 rRP        lfd,
  460.     fr28    -32 rRP        lfd,
  461.     fr29    -24 rRP        lfd,
  462.     fr30    -16    rRP        lfd,
  463.     fr31    -8    rRP        lfd,
  464.                         blr,
  465. ;ppc_code
  466.  
  467.  
  468.  
  469. :ppc_code (EX)        ¥ called from EXECUTE, once we've handled a possible
  470.                     ¥  indirection via a vector.
  471.  
  472. ¥ in a code defn we always have 2 stack cells and 2 floating stack cells in regs on
  473. ¥  entry.  So here we have r4 = xt to execute, r3 = next cell down.  We can scribble 
  474. ¥  on r5-10 until we get the parms into regs.
  475.  
  476. ¥ If this is a method, the obj addr will be rY (r12), so we have to leave
  477. ¥  that alone for the first part.
  478.  
  479.     r0                        mflr,        ¥ save lr on return stack
  480.     r0        -8    rRP            stwu,
  481.  
  482.     fr2        -16    rFSP        stfd,        ¥ push of fr1 and fr2 - all FP stk cells now in mem
  483.     fr1        -8    rFSP        stfd,
  484.     rFSP    -24                addi,        ¥ leave rFSP 8 bytes lower than usual, to simplify
  485.                                         ¥  what follows
  486.  
  487.     rX        r4                mr,            ¥ rX = addr of flag bytes of defn we're executing
  488.     r5        -2    rX            lhz,        ¥ r5 = handler code, which we now check
  489.     r0        r5     $ FF00        andi.,        ¥ BExx is OK
  490.     r0        $ BE00            cmpli,
  491.  
  492. ne if,
  493.     r0        $ BD00            cmpli,
  494.  eq if,
  495.     r6        rX                lhz,        ¥ OK - there'll be boilerplate code after
  496.      r6        r6    $ FF        andi.,        ¥  the info bytes.  r6 = # info bytes
  497.      rX        rX    r6            add,        ¥ add to addr in rX.  Now we need to add 2 for
  498.                                          ¥ the extra info mark and len, then off-align (by
  499.                                          ¥ adding 5, 4-byte aligning, then subtracting 2)
  500.      rX        rX    7            addi,        ¥ so we combine the 5 and 2 and add 7
  501.     rX        rX 0 0 29        rlwinm,        ¥ back to 4-byte boundary
  502.      rX        rX    -2            addi,        ¥ now rX -> flag bytes for boilerplate code
  503.  else,
  504.     r0        ' execErr 2+    dicaddr,
  505.     r0                        mtctr,
  506.                             bctr,
  507.  then,
  508. then,
  509.  
  510. ¥ now we get the flag bytes to r6, and the FP flag bytes to r7.
  511.  
  512.     r6        0    rX            lhz,        ¥ r6 = flag bytes
  513.  
  514.     r3        -4    rSP            stw,        ¥ push off r3 - all stk cells are now in mem
  515.     rSP        -8                addi,        ¥ leave rSP 4 bytes lower than usual, to simplify
  516.                                         ¥  what follows
  517.                                         
  518.     r0        r6    $ 1000        andi.,        ¥ look at "fp" bit in flags
  519.  ne if,
  520.       r7    4    rX            lhz,        ¥ if set, get FP flag bytes to r7
  521.  else,
  522.        r7    $ 0200            li,            ¥ otherwise put default flag bytes there
  523.  then,
  524.  
  525.     r0        r6    $ 8000        andi.,        ¥ look at "leaf" bit in flags
  526.     
  527. ne if,
  528. ¥ it's a leaf routine.  We do the work of the prolog and epilog here rather than in
  529. ¥  the called routine.  r3 is unused here so we can use it.
  530.  
  531. ¥ First we save the FPRs, since we know RP is 8-byte aligned:
  532.  
  533.     r3        r7 2 26 29        rlwinm,        ¥ r3 = # FP parm+locals, times 4
  534.     r0        ' fsaves 46 +    dicaddr,    ¥ addr of end of "fsaves" code to r0
  535.     r0        r3 r0            subf,        ¥ subtract offset
  536.     r0                        mtctr,
  537.                             bctrl,        ¥ save the required FP regs
  538.     r0        r3    r3            add,        ¥ double offset for rRP decrement
  539.     rRP        r0    rRP            subf,        ¥ decrement rRP over saved FPRs
  540.  
  541. ¥ Now we save the GPRs:
  542.  
  543.     r3        r6 2 26 29        rlwinm,        ¥ r3 = # parms+locals, times 4
  544.     r0        ' saves 46 +    dicaddr,    ¥ addr of end of "saves" code to r0
  545.     r0        r3 r0            subf,        ¥ subtract offset
  546.     r0                        mtctr,
  547.                             bctrl,        ¥ save the required regs
  548.     rRP        r3    rRP            subf,        ¥ decrement rRP over saved regs
  549.  
  550.  
  551.     r0        r5    $ FF        andi.,
  552.     r0        $ 40            cmpli,        ¥ method?
  553.  eq if,
  554.     r20        -4    rRP            stwu,        ¥ yes - save r20
  555.     r20        rY                mr,            ¥ and move rY to there
  556.  then,
  557.  
  558. ¥ now we look after the parms themselves - we set up for them to go straight to
  559. ¥  their ultimate destination regs.  First any FP parms:
  560.  
  561.     r3        r7 30 26 29        rlwinm,        ¥ r3 = # FP parms, times 4
  562.     r0    ' fpullParms 34 +    dicaddr,    ¥ addr of end of "pullParms" code to r0
  563.     r0        r3 r0            subf,        ¥ subtract offset
  564.     r0                        mtctr,
  565.                             bctrl,        ¥ pull the FP parms we need into regs up to fr31
  566.  
  567. ¥ now we look after any FP stack cells that have to go to regs - this will only
  568. ¥  happen if our default call_cnt (2) is greater than the number of named parms.
  569. ¥ Note the most pulls we'll do is to fr1 and fr2.
  570.  
  571.     r0        8                li,
  572.     r3        r3    r0            subf.,        ¥ r3 = 8 - ( # FP parms * 4 )
  573.  gt if,
  574.     r0        ' fpulls 42 +    dicaddr,    ¥ addr of end of "pulls" code to r0
  575.     r0        r3 r0            subf,        ¥ subtract offset
  576.     r0                        mtctr,
  577.                             bctrl,        ¥ pull the floating stack cells we need into regs
  578.  then,
  579.  
  580.     r3        r6 30 26 29        rlwinm,        ¥ r3 = # parm bytes
  581.     r0    ' pullParms 34 +    dicaddr,    ¥ addr of end of "pullParms" code to r0
  582.     r0        r3 r0            subf,        ¥ subtract offset
  583.     r0                        mtctr,
  584.                             bctrl,        ¥ pull the parms we need into regs up to r31
  585.     
  586. ¥ now we look after any stack cells that have to go to regs - this will only
  587. ¥  happen if our default call_cnt (2) is greater than the number of named parms.
  588. ¥ Note the most pulls we'll do is to r3 and r4, so r5-7 will be untouched.
  589.  
  590.     r0        8                li,
  591.     r3        r3    r0            subf.,        ¥ r3 = 8 - # parm bytes
  592.  gt if,
  593.     r0        ' pulls 34 +    dicaddr,    ¥ addr of end of "pulls" code to r0
  594.     r0        r3 r0            subf,        ¥ subtract offset
  595.     r0                        mtctr,
  596.                             bctrl,        ¥ pull the stack cells we need into regs
  597.  then,
  598.  
  599. ¥ before we call the routine we save the flag bytes, the handler code and rX,
  600. ¥  since we need them later.  In this leaf handling code we have to do this
  601. ¥  last since we've saved regs for the callee, and we'll need to restore
  602. ¥  these quantities first.
  603.  
  604.     r5        -4    rRP            stwu,
  605.     r6        -4    rRP            stwu,
  606.     rX        -4    rRP            stwu,
  607.  
  608. else,
  609. ¥  not a leaf routine.
  610.  
  611. ¥ first we save the same quantities as above - but here we have to do it first,
  612. ¥  since we might be clobbering r5/r6 if the callee needs them.
  613.  
  614.     r5        -4    rRP            stwu,
  615.     r6        -4    rRP            stwu,
  616.     rX        -4    rRP            stwu,
  617.  
  618.     r3        r7 30 26 29        rlwinm,        ¥ r3 = # fp parms, times 4
  619.     r0        8                li,
  620.     r3        r0                cmp,
  621.  lt if,
  622.       r3    r0                mr,            ¥ if < 8, make it 8 since that's our minimum
  623.  then,
  624.     
  625.     r0        ' fpulls 42 +    dicaddr,    ¥ addr of end of "fpulls" code to r0
  626.     r0        r3 r0            subf,        ¥ subtract offset
  627.     r0                        mtctr,
  628.                             bctrl,        ¥ pull the fp cells we need into fp regs
  629.  
  630.     r3        r6 30 26 29    rlwinm,            ¥ r3 = # parms, times 4
  631.     r0        8                li,
  632.     r3        r0                cmp,
  633.  lt if,
  634.       r3    r0                mr,            ¥ if < 8, make it 8 since that's our minimum
  635.  then,
  636.     
  637.     r0        ' pulls 34 +    dicaddr,    ¥ addr of end of "pulls" code to r0
  638.     r0        r3 r0            subf,        ¥ subtract offset
  639.     r0                        mtctr,
  640.                             bctrl,        ¥ pull the cells we need into regs
  641.  
  642. then,
  643.  
  644.     rSP        4                addi,        ¥ stack ptrs back to normal
  645.     rFSP    8                addi,
  646.  
  647. ¥ now we have to 8-byte align the RP since anything might happen in the callee.
  648. ¥ If we have to do it we'll push a 4-byte zero.  Since rX, the last reg we saved
  649. ¥  there, can never be zero, this lets us sorts things out when the callee returns.
  650.  
  651.     r0        rRP    7            andi.,
  652. ne if,
  653.     r0        0                li,
  654.     r0        -4    rRP            stwu,
  655. then,
  656.  
  657. ¥ now we're going to call the routine - first we need the address of its
  658. ¥  first instruction.
  659.  
  660.     r0        r6    $ 1000        andi.,        ¥ look at "fp" bit in flags
  661. ne if,
  662.     r0        rX    6            addi,
  663. else,
  664.     r0        rX    2            addi,        ¥ addr of code to r0
  665. then,
  666.  
  667.     r0                        mtctr,
  668.  
  669. ¥ **************************************************************************
  670.                             bctrl,        ¥ call it
  671. ¥ **************************************************************************
  672.  
  673. ¥ At this point we have to allow for the maximum number of live values
  674. ¥  in GPRs, which is 6.  This means r9 will always be free here,
  675. ¥  and we can also use r0, rX, rY and rZ (aka r10).
  676.  
  677.     rX        0    rRP            lwz,        ¥ restore rX
  678.     rX        0                cmpi,
  679. eq if,                                    ¥ but if we got zero, it was alignment
  680.     rRP        4                addi,        ¥  padding, so we skip it and try again
  681.     rX        0    rRP            lwz,        ¥ restore rX
  682. then,
  683.     r10        4    rRP            lwz,        ¥ restore flag bytes, into r10 this time
  684.     r9        8    rRP            lwz,        ¥ restore handler code to r9
  685.     rRP        12                addi,
  686.  
  687. ¥ all we need from the handler code is whether this is a method or not, so
  688. ¥  we'll get this to cr1, then we can reuse r9.
  689.  
  690.     r0        r9    $ FF        andi.,
  691.     cr1        r0    $ 40        cmpli,        ¥ cr1 is "equal" if it's a method
  692.  
  693.     r0        r10    $ 1000        andi.,        ¥ look at "fp" bit in flags
  694.  ne if,
  695.       r9    4    rX            lhz,        ¥ if set, get FP flag bytes to r9
  696.  else,
  697.        r9    $ 0200            li,            ¥ otherwise put default flag bytes there
  698.  then,
  699.  
  700.     r0        r10    $ 8000        andi.,        ¥ test "leaf" bit in flags
  701. ne if,
  702. ¥ it was a leaf routine.
  703.  
  704.  cr1 eq if,                                ¥ method?
  705.     r20        rRP                lwz,        ¥ yes - restore r20
  706.     rRP        4                addi,
  707.  then,
  708.  
  709.     rY        r10 2 26 29        rlwinm,        ¥ rY = # parms+locals, times 4
  710.     r0        ' restores 46 +    dicaddr,    ¥ addr of end of "restores" code to r0
  711.     r0        rY r0            subf,        ¥ subtract offset
  712.     rRP        rRP    rY            add,        ¥ increment rRP over saved GPRs
  713.     r0                        mtctr,
  714.                             bctrl,        ¥ restore the saved regs
  715.  
  716.     rY        r9 2 26 29        rlwinm,        ¥ rY = # FP parm+locals, times 4
  717.     r0    ' frestores 46 +    dicaddr,    ¥ addr of end of "frestores" code to r0
  718.     r0        rY r0            subf,        ¥ subtract offset
  719.     rRP        rY                add,        ¥ increment rRP over saved FPRs (8 bytes
  720.     rRP        rY                add,        ¥  each)
  721.     r0                        mtctr,
  722.                             bctrl,        ¥ restore the saved FPRs    
  723. then,
  724.  
  725. ¥ now we push off all result regs to mem - we return 2 in GPRs and 2 in FPRs
  726. ¥ from here, but it's easiest to grab those back after the pushes.
  727.  
  728.     rY        r10 26 26 29    rlwinm,        ¥ rY = # result regs, times 4
  729.     r0        ' pushes 34 +    dicaddr,    ¥ addr of end of "pushes" code to r0
  730.     r0        rY    r0            subf,        ¥ subtract offset
  731.     r0                        mtctr,
  732.                             bctrl,        ¥ push all result regs to mem
  733.     rSP        rY rSP            subf,        ¥ adjust stack ptr
  734.  
  735.      rY        r9 26 26 29        rlwinm,        ¥ rY = # FP result regs, times 4
  736.     r0        ' fpushes 34 +    dicaddr,    ¥ addr of end of "fpushes" code to r0
  737.     r0        rY    r0            subf,        ¥ subtract offset
  738.     r0                        mtctr,
  739.                             bctrl,        ¥ push all result regs to mem
  740.     rY        rY                add,
  741.     rFSP    rY rFSP            subf,        ¥ adjust stack ptr
  742.  
  743.  
  744.     r4        0    rSP            lwz,
  745.     r3        4    rSP            lwz,
  746.     rSP        8                addi,
  747.     
  748.     fr2        0    rFSP        lfd,
  749.     fr1        8    rFSP        lfd,
  750.     rFSP    16                addi,
  751.  
  752.     r0        0    rRP            lwz,
  753.     rRP     8                addi,
  754.     r0                        mtlr,        ¥ restore lr
  755.                             blr,        ¥ and return.
  756. ;ppc_code        uses_ctr
  757.  
  758.  
  759. : EXECUTE  ( xt -- ?? )
  760.     dup 2- w@ $ BC41 =
  761.     IF                            ¥ it's a MARKER
  762.         2+ fmrk  EXIT
  763.     THEN
  764.  
  765.     dup 2- w@ $ BC0C =
  766.     IF                            ¥ it's a DOES> word
  767.         dup 2+ @abs                ¥ get addr of CREATEd data
  768.         swap 6 + @abs            ¥ and xt of DOES> code
  769.     ELSE
  770.         BEGIN
  771.             dup 2- w@ $ BC05 =
  772.         WHILE                    ¥ it's a vector
  773.             2+ @abs                ¥ goto data area
  774.             @abs                ¥ pick up dest xt
  775.         REPEAT                    ¥ and loop in case we get another vector
  776.     
  777.         dup 2- w@ $ BD2E =
  778.         IF                        ¥ it's an exported word
  779.             ['] enterMod        ¥ for these we execute enterMod which
  780.         THEN                    ¥  does the work
  781.     THEN
  782.  
  783.     (ex)            ¥ (ex) does the actual work of executing the word
  784. ;
  785.  
  786.  
  787. : DoVect
  788.     @abs execute  ;
  789.  
  790. : DoSvect
  791.     dup @ NIF  4+  THEN
  792.     @abs execute  ;
  793.  
  794. : ^THEPORT  ( -- addr )
  795.     inline{ qd 256 +}  ;        ¥ should theoretically only be 110, but we
  796.                                 ¥  seem to need more - see comment at qd
  797.  
  798. : THEPORT  ( -- addr-of-GrafPort )
  799.     inline{ qd 256 + @}  ;
  800.  
  801.  
  802. : SCREENBITS  { ¥ ^rect -- l t r b }
  803.     qd  $ 8c +  -> ^rect
  804.     ^rect 2+  w@  ^rect    w@
  805.     ^rect 6 + w@  ^rect 4+ w@
  806. ;
  807.  
  808.  
  809. ¥ we call PREPARE_SYSCALLS at startup time to get the shared libraries
  810. ¥  we need.  Currently, these are InterfaceLib and MathLib.
  811.  
  812. : get_shared_library  { addr -- connID true  | -- false }
  813.     addr                        ¥ addr is pascal string
  814.     'type pwpc                    ¥ PowerPC library
  815.     1                            ¥ load the library if not loaded
  816.     vConnID
  817.     mainAddr
  818.     errName
  819.     %_GetSharedLibrary  IF  false  EXIT  THEN
  820.     vConnID @  true
  821. ;
  822.  
  823. : get_connID  { ^extern ¥ ^lib ^connID -- connID }
  824.             ¥ gets the connID for an arbitrary shared library
  825.     ^extern 10 + @abs  -> ^lib
  826.     ^lib 2+ @abs  -> ^connID
  827.     ^connID @  ?dup ?EXIT
  828.  
  829. ¥ not connected yet - we do it now
  830.     ^lib  6 +  get_shared_library
  831.     NIF  999 die  THEN
  832.     dup  ^connID !
  833. ;
  834.  
  835.  
  836. : PREPARE_SYSCALLS  ( -- )
  837.     " InterfaceLib" drop 1-
  838.     get_shared_library  not ?startUpError
  839.     -> InterfaceLib_connID
  840.  
  841.     " MathLib" drop 1-
  842.     get_shared_library  not ?startUpError
  843.     -> MathLib_connID
  844. ;
  845.  
  846.  
  847. : get_transition_vector  { ^extern ¥ extern? ^tv connID -- }
  848.     ^extern 10 + @
  849.     IF        ¥ this is an EXTERN.  We look in the given library.
  850.         ^extern get_connID
  851.     ELSE    ¥ it's a syscall.  We look in InterfaceLib and MathLib.
  852.         InterfaceLib_connID
  853.     THEN  -> connID
  854.  
  855.     ^extern 6 + @abs  -> ^tv
  856.     ^tv @  nilP =
  857.     IF            ¥ hasn't been called yet - we resolve it now
  858.         connID  
  859.         ^extern 14 +            ¥ addr of symbol (Pascal string)
  860.         ^tv                        ¥ addr of location where resolved pointer will go
  861.         symClass
  862.         %_FindSymbol
  863.         IF                ¥ didn't find it there - try in MathLib
  864.             MathLib_connID
  865.             ^extern 14 +        ¥ addr of symbol (Pascal string)
  866.             ^tv                    ¥ addr of location where resolved pointer will go
  867.             symClass
  868.             %_FindSymbol
  869.             ?symbolError        ¥ if we still didn't find it, fail
  870.         THEN
  871.     THEN
  872.     ^tv @  -> rY
  873.     [    $ 800C0000 code,        ¥ lwz  r0, (r12) - get dest addr to r0
  874.         $ 7C0903A6 code,        ¥ mtctr r0         - and then to ctr
  875.     ]
  876. ;
  877.  
  878.  
  879. : SETUP  { ¥ hndl addr entPt codeSz dataSz cg_code cg_data
  880.                 total_code total_data flags chopped -- }
  881.  
  882.     initial_entry_point
  883.     fix_sys_SP
  884.  
  885. ¥ First we grow the application heap:
  886.     %_MaxApplZone
  887.  
  888. ¥ now we allocate a block for the return stack:
  889.     rstack_size %_NewHandleClear  -> hndl
  890.     hndl %_MoveHHi
  891.     hndl %_HLock
  892.     hndl @  -> addr
  893.     addr rstack_size +  -> RP        ¥ RP is set up - now we can do calls!
  894.  
  895.     $ CD  $ AB                        ¥ leave markers on the stack - these might also
  896.                                     ¥  hopefully catch a stack underflow
  897.  
  898.     $ CDCD >r  $ ABAB >r            ¥ and also on the return stack
  899.  
  900. ¥ now we grab the items we need out of the info block
  901. ¥  at the start of the code area
  902.  
  903.     entry_point_toc_offset  RTOC + @  -> entPt
  904.     entPt 4 + @        -> codeSz
  905.     entPt 8 + @        -> dataSz
  906.     entPt 12 + @    -> cg_code
  907.     entPt 16 + @    -> cg_data
  908.     entPt 52 + @    -> flags
  909.  
  910. ¥ now we set up the base regs and the segment table so we can
  911. ¥  address things.  First the data area:
  912.  
  913.     flags 1 and
  914.     IF            ¥ this is an installed app.
  915.         dataSz -> total_data
  916.         RTOC -> addr
  917.     ELSE        ¥ we're in the development environment, so the data
  918.                 ¥  area goes in a handle:
  919.         dataSz extra_data +  -> total_data
  920.         total_data  lockedHndl  -> addr
  921.         RTOC  addr  dataSz  call_BlockMove
  922.     THEN
  923.  
  924.     addr cg_data + half_displ_range +  -> mainData
  925.     -1 -> modData
  926.  
  927. ¥ with the data area set up, we can now store to it!
  928.  
  929.     entPt 60 + @  -> chopped
  930.     total_data  chopped +    segTable  8 + !
  931.     addr  chopped -            segTable 12 + !
  932.  
  933.     addr -> data_start
  934.     addr cg_data +  -> nuc_data_start
  935.     addr total_data +  -> data_limit
  936.     addr dataSz +  -> DP
  937.  
  938. ¥ now the code area
  939.  
  940.     flags 1 and
  941.     IF            ¥ this is an installed app.
  942. ¥        true -> instld?                ¥ in case it wasn't set already
  943.         codeSz -> total_code
  944.         entPt -> addr
  945.     ELSE
  946.         codeSz extra_code +  -> total_code
  947.         total_code  lockedHndl  -> addr
  948.         entPt  addr  codeSz  call_BlockMove
  949.     THEN
  950.  
  951.     addr cg_code + half_displ_range +  -> mainCode
  952.     -1 -> modCode
  953.  
  954.     entPt 56 + @  -> chopped
  955.     total_code  chopped +    segTable !
  956.     addr  chopped -            segTable 4+ !
  957.  
  958.     addr -> code_start
  959.     addr cg_code +  -> nuc_code_start
  960.     addr total_code +  -> code_limit
  961.     addr codeSz +  dup -> CDP -> prev_CDP
  962.  
  963.     addr 20 +  -> context
  964.     
  965.     flags 1 and
  966.     NIF            ¥ development
  967.         addr codeSz  %_MakeDataExecutable
  968.  
  969. ¥ now the interesting bit - we switch execution into the handle
  970. ¥  where we just moved the code!
  971.         entPt  addr  switch_me
  972.     THEN
  973.  
  974. ¥ now the FP stack area:
  975.     fstack_size 20 +  lockedHndl
  976.     fstack_size +  -> FSP
  977.  
  978. ¥ now set up the values with the base addrs of the 3 stacks:
  979.  
  980.     SP    -> SP0                ¥ no cells in regs just here, as it turns out
  981.     RP    -> RP0
  982.     -1 -> (^base)            ¥ no current object
  983.  
  984.     $ 7ff86400    ftemp !        ¥ quiet NAN(100)
  985.  
  986.     ftemp sf@  ftemp sf@    ¥ put 4 of them at base of FP stack
  987.     ftemp sf@  ftemp sf@
  988.     
  989.     0 ftemp !  ftemp f@ -> 0.0        ¥ initialize fpr14 to zero (we use it
  990.                                     ¥  as a permanent source of zero)
  991. ¥ now init the managers
  992.  
  993.     ^thePort %_InitGraf        ¥ note: what we have to pass to InitGraf is the
  994.                             ¥  addr of thePort which is a pointer near the END
  995.                             ¥  of the QD globals record!
  996.  
  997.     FSP 48 - -> FSP0        ¥ The external call has pushed all our dummy FP
  998.                             ¥  cells into mem at this point
  999.  
  1000.     %_InitFonts
  1001.     %_InitWindows
  1002.     %_TeInit
  1003.     %_InitMenus
  1004.     %_InitCursor
  1005.  
  1006. ¥ now we allocate a block for fFcb, TIB, PAD and the error dump area, and
  1007. ¥  set up fFcb (which is an object pointer) pointing there.  fFcb will be set up
  1008. ¥  properly when Files is loaded.
  1009.  
  1010.     FBlkLen 10 +  lockedHndl  -> addr    ¥ the 10 is just a safety margin
  1011.     8 ++> addr                            ¥ leave room for obj header
  1012.     addr  ffcb !
  1013.     FCBlen ++> addr        addr -> pad
  1014.     PADlen ++> addr        addr -> TIB
  1015.     TIBlen ++> addr        addr -> ^errDump
  1016.  
  1017. ¥ Noe we get the shared lib for system calls.  After this we can
  1018. ¥  execute syscall words.
  1019.  
  1020.     prepare_syscalls
  1021.  
  1022.     %_NewRgn  -> theRgn
  1023.  
  1024. ¥ now if needed, we get our low-level window fWind.
  1025.  
  1026.     fWind?
  1027.     IF    256                ¥ resID
  1028.         fWind
  1029.         -1
  1030.         %_GetNewWindow
  1031.         %_SetPort
  1032.         fWind -> addr
  1033.         9  addr 74 +  w!            ¥ point size = 9
  1034.         4  addr 68 +  w!            ¥ font = Monaco
  1035.     
  1036.         addr 16 + @  addr 156 + !    ¥ set fWind's contRect in case not done
  1037.         addr 20 + @  addr 160 + !
  1038.  
  1039.         addr 16 + @  fpRect !        ¥ set fpRect (used for scrolling)
  1040.         addr 20 + @  fpRect 4 + !
  1041.  
  1042. ¥        %_NewRgn  -> theRgn
  1043.         0   %_TextMode
  1044.         
  1045.         true -> emit?
  1046.     THEN
  1047.  
  1048.     objInit
  1049.     run
  1050.  
  1051.     %_ExitToShell
  1052. ;
  1053.